Unit BRequestUnit;

{$mode objfpc}{$H+}

Interface

Uses
  sysutils, fgl, Classes, lNet, strutils;

Const
  rrError = 0;
  rrResponse = 1;
  rrCallSession = 2;

  rsError = 0;
  rsCompleted = 1;
  rsProcessing = 2;
  rsWaitingForSession = 3;
  rsSuspended = 4;

Type

{ BRequestClass }

 BRequestClass = Class
  Private
    bNewCookies: String;
    bSocket: TLSocket;

    bCookies: TStringList;
    bHeaders: TStringList;
    bGetQueries: TStringList;
    bPostQueries: TStringList;
    bResponse: String;
    bStatus: Integer;

    Function ExtractSubstring(Var aString: String;
      Const aDelimeter: String): String;

    Procedure ParseGetQuery(Const aQuery: String);
    Procedure ParsePostQuery(Const aQuery: String);
    Procedure ParseCookie(Const aCookie: String);
  Public
    Property Headers: TStringList Read bHeaders;
    Property GetQueries: TStringList Read bGetQueries;
    Property PostQueries: TStringList Read bPostQueries;
    Property Cookies: TStringList Read bCookies;
    Property NewCookies: String Read bNewCookies;
    Property Response: String Read bResponse Write bResponse;
    Property Status: Integer Read bStatus;

    Function ByString(Const aParam: String;
      Const aPostOnly: Boolean = TRUE): String;
    Function ByInteger(Const aParam: String;
      Const aPostOnly: Boolean = TRUE): Integer;

    Procedure SetCookie(Const aCookie: String);
    Function ParseRequest(aBuffer: String): Boolean;

    Procedure Send;
    Procedure SendError(Const aNumber: Integer = 500;
      Const aMessage: String = 'Strange error');

    Constructor Build(Const aSocket: TLSocket);
    Destructor Burn;
End;

//TODO : replace for BPrimitiveList;
Type BRequestsList = Specialize TFPGList<BRequestClass>;
Type BRequestsThreadList = TThreadList;

Implementation

{ BRequestClass }

Function BRequestClass.ExtractSubstring(Var aString: String;
  Const aDelimeter: String): String;
Var
  aIndex: Integer;
Begin
  aIndex := Pos(aDelimeter, aString);
  If Not(aIndex = 0) Then
    Begin
      Result:= Copy(aString, 1, aIndex - 1);
      Delete(aString, 1, aIndex);
    End
  Else
    Begin
      Result := aString;
      aString := '';
    End;
End;

Procedure BRequestClass.ParseGetQuery(Const aQuery: String);
Var
  aBuffer: String;
  aParam: String;
Begin
  aBuffer := aQuery;
  While Not(aBuffer = '') Do
    Begin
      aParam := ExtractSubstring(aBuffer, '&');
      If Not(aParam = '') Then bGetQueries.Add(aParam);
    End;
End;

Procedure BRequestClass.ParsePostQuery(Const aQuery: String);
Var
  aBuffer: String;
  aParam: String;
Begin
  aBuffer := aQuery;
  While Not(aBuffer = '') Do
    Begin
      aParam := ExtractSubstring(aBuffer, '&');
      If Not(aParam = '') Then bPostQueries.Add(aParam);
    End;
End;

Procedure BRequestClass.ParseCookie(Const aCookie: String);
Var
  aBuffer: String;
  aIndex: Integer;
Begin
  //TODO: change to PosEx
  aBuffer := aCookie;
  aIndex := Pos(';', aBuffer);
  While Not(aIndex = 0) Do
    Begin
      bCookies.Add(Trim(Copy(aBuffer, 1, aIndex - 1)));
      Delete(aBuffer, 1, aIndex);
      aIndex := Pos(';', aBuffer);
    End;
  If Not(Trim(aBuffer) = '') Then
    bCookies.Add(Trim(aBuffer));
End;

Function BRequestClass.ByString(Const aParam: String; Const aPostOnly: Boolean
  ): String;
Begin
  Result := PostQueries.Values[aParam];
End;

Function BRequestClass.ByInteger(Const aParam: String;
  Const aPostOnly: Boolean): Integer;
Begin
  Result := StrToIntDef(ByString(aParam), -1);
End;

Procedure BRequestClass.SetCookie(Const aCookie: String);
Begin
  If bCookies.IndexOf(aCookie) > 0 Then Exit
  Else bNewCookies += aCookie;
End;

Function BRequestClass.ParseRequest(aBuffer: String): Boolean;
Var
  aIndex: Integer;
  aReceived: Integer = 0;
  aSize: Integer = 0;
  aStep: Integer = 0;
  aContentSize: Integer;
  aStrings: TStringList;
  aHeader, aValue: String;
  aStream: TMemoryStream;
  aFile: String;

  aDebug: String;
Begin
  Result := FALSE;
  aSize := StrToIntDef(ExtractSubstring(aBuffer, ':'), -1);
  If Not(aSize > 0) Then Begin WriteLn(aBuffer); Exit;End;
  While Not(aBuffer = '') Do
    Begin
      aHeader := ExtractSubstring(aBuffer, #0);
      If aHeader = '' Then Exit;
      aValue := ExtractSubstring(aBuffer, #0);
      aReceived += Length(aHeader + aValue);
     Case aHeader Of
        'QUERY_STRING': ParseGetQuery(aValue);
        'REQUEST_BODY': ParsePostQuery(aValue);
        'HTTP_COOKIE': ParseCookie(aValue);
      Else
        bHeaders.Values[aHeader] := aValue;
      End;
    End;
  Result := TRUE;
End;

Procedure BRequestClass.Send;
Begin
  Try
    bSocket.SendMessage('Status: 200 OK'#13#10'Content-Type: text/html'#13#10 +
      IfThen(bNewCookies = '', '', 'Set-Cookie:' + bNewCookies + #13#10) +
      #13#10 + Response);
  Except On E: Exception Do
    WriteLn(E.Message);
  End;
End;

Procedure BRequestClass.SendError(Const aNumber: Integer;
  Const aMessage: String);
Begin
  bSocket.SendMessage(Format('Status: %d OK'#13#10'Content-Type: text/html' +
    #13#10#13#10'%s', [aNumber, aMessage]));
  bSocket.Disconnect;
End;

Constructor BRequestClass.Build(Const aSocket: TLSocket);
Begin
  bSocket := aSocket;
  bHeaders := TStringList.Create;
  bGetQueries := TStringList.Create;
  bPostQueries := TStringList.Create;
  bCookies := TStringList.Create;
End;

Destructor BRequestClass.Burn;
Begin
  bHeaders.Free;
  bGetQueries.Free;
  bPostQueries.Free;
  bCookies.Free;
  Try
    bSocket.Disconnect;
  Except
  End;
End;

End.

